perm filename COPYIT.F4[RST,LCS] blob sn#206560 filedate 1976-03-14 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	C***** COPYIT, UPDN, STFCH ****** (OUTLIM, GETPTS, MOVIT -ALL OLD)
C00008 ENDMK
CāŠ—;
C***** COPYIT, UPDN, STFCH ****** (OUTLIM, GETPTS, MOVIT -ALL OLD)

	SUBROUTINE COPYIT
	INTEGER PWDS
	COMMON/XRN/RN(4000)  /KJY/ DONT,JY /POSI/S(8),JJ2,P
	COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
	1/PTR/PWDS(250),ITEM,LL,I,IX
	EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
	1,(R6,RJQ(4)),(N,RN(2500))

	IM=ITEM
	DO 1 K=1,IM
	L=PWDS(K)
	IF(RTLINE(L))GO TO 1
	IF(OUTLIM(L,3))GO TO 1
	IF(R6.NE.0.AND.R6.NE.RN(L+1))GO TO 1
	M=RN(L)+2
	CALL LOOP(0,M,1,I,L,RN)
	ITEM=ITEM+1
	L=PWDS(ITEM)
	RN(L+2)=R7
	IF(JJ2)JJ2=ITEM
	I=I+M+1
	PWDS(ITEM+1)=I
1	CONTINUE
	R2=R7
	END
	SUBROUTINE STFCH
	INTEGER PWDS
	COMMON/XRN/RN(4000)  /KJY/ DONT,JY /POSI/S(8),JJ2,P
	COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
	1/PTR/PWDS(250),ITEM,LL,I,IX
	EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
	1,(R6,RJQ(4))

	DO 1 K=1,ITEM
	L=PWDS(K)
	IF(RTLINE(L))GO TO 1
	IF(OUTLIM(L,3))GO TO 1
	IF(RN(L+1).NE.R6.AND.R6.NE.0)GO TO 1
C DIDN'T MATCH THE CODE NUM.
	IF(JJ2)JJ2=K
	RN(L+2)=R7
1	CONTINUE
	END

	SUBROUTINE UPDN(NST)
	INTEGER PWDS
	COMMON/XRN/RN(4000)  /KJY/ DONT,JY /POSI/S(8),JJ2,P
	COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
	1/PTR/PWDS(250),ITEM,LL,I,IX
	EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R11,RJQ(9))
	1,(R6,RJQ(4))

	DO 1 K=NST,ITEM
	L=PWDS(K)
	IF(RTLINE(L))GO TO 1
	RY=RN(L+1)
	IF(RY.GT.16)GO TO 1
	IF(RY.EQ.8)GO TO 1
	IF(RY.EQ.3)GO TO 1
	IF(RY.EQ.R6)GO TO 10
	IF(R6.NE.0)GO TO 1
C DIDN'T MATCH THE CODE NUM.
10	IF(RY.NE.4)GO TO 11
	IF(RN(L).LT.3)GO TO 1
C A BAR LINE
11	IF(OUTLIM(L,3))GO TO 2
	RN(L+4)=RN(L+4)+R11
	IF(JJ2)JJ2=K
2	IF(RY.LT.4)GO TO 1
	IF(RY.GT.7)GO TO 1
	IF(RY.EQ.7)GO TO 1 
C NO WIGGLE ON TRILL
	IF(RY.NE.4.)GO TO 12
	IF(RN(L+5).EQ.50)GO TO 1
C  CRESC. OR BOX
12	IF(OUTLIM(L,6))GO TO 1
	RN(L+5)=RN(L+5)+R11
	IF(JJ2)JJ2=K
1	CONTINUE
	END

CF	SUBROUTINE GETPTS
CF	DIMENSION N(500),NP(500)
CF	COMMON/XRN/RN(4000)  /KJY/ K,J
CF	COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
CF	1/PTR/PWDS(250),ITEM,LL,I,IX
CF	EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R11,RJQ(9))
CF	1,(R6,RJQ(4)),(N,RN(2500)),(NP,RN(3000))
CF	J=0
CF	K=0
CF	DO 1 M=1,ITEM
CF	L=PWDS(M)
CF	IF(RTLINE(L))GO TO 1
CF	RY=RN(L+1)
CF	IF(R6.LE.0)GO TO 9
C  CHECK CODE NUM
CF	IF(R6.NE.RY)GO TO 1
CF9	IF(OUTLIM(R4,R5,RN(L+3)))GO TO 2
C  IN LIMITS?
CF	IF(JJ2)JJ2=M	**** ALSO AT 6,8 AND 5 ***
CF	J=J+1
CF	N(J)=L+3
CF	K=K+1
CF	NP(K)=L
C  FOR USE IN JUSTIFY ROUTINE
CF2	IF(RY.LT.4)GO TO 1
CF	IF(RY.GT.7)GO TO 1
C  TWO-ENDED ITEM?
CF	RZ=RN(L)
C  WD CNT
CF	GO TO(4,5,6,7),IFIX(RY)-3
CF4	IF(RZ.GT.2)GO TO 5
CF	GO TO 1
CF7	IF(RZ.GT.4)GO TO 5
CF	GO TO 1
CF6	IF(RZ.LT.8)GO TO 8
CF	IF(RN(L+10).LT.30)GO TO 8
CF	IF(OUTLIM(R4,R5,RN(L+8)))GO TO 8
CF	J=J+1
CF	N(J)=L+8
CF	IF(RZ.LT.7)GO TO 5
CF	IF(OUTLIM(R4,R5,RN(L+9)))GO TO 5
CF	J=J+1
CF	N(J)=L+9
CF5	IF(OUTLIM(R4,R5,RN(L+6)))GO TO 1
CF	J=J+1
CF	N(J)=L+6
CF1	CONTINUE
CF	END

CF	FUNCTION OUTLIM(A,B,C)
CF	OUTLIM=-1
CF	IF(C.LT.A)RETURN
CF	IF(C.GT.B)RETURN
CF	OUTLIM=0 
CF	END
CF	SUBROUTINE MOVIT
CF	DIMENSION N(500)
CF	COMMON/XRN/RN(4000)  /KJY/ DONT,J
CF	COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
CF	EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R9,RJQ(7))
CF	1,(R6,RJQ(4)),(N,RN(2500)),(R8,RJQ(6))
CF	RDIS=(R9-R8)/(R5-R4)
CF	DO 1 K=1,J
CF	L=N(K)
CF	RA=RN(L)
CF	IF(OUTLIM(R4,R5,RA))GO TO 1
CF	IF(R9.NE.0)RA=(RA-R4)*RDIS
CF	RN(L)=R8+RA
CF1	CONTINUE
CF	END